home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / perl5.005.tar.gz / perl5.005.tar / perl5.005 / lib / dumpvar.pl < prev    next >
Perl Script  |  1998-02-03  |  11KB  |  411 lines
  1. require 5.002;            # For (defined ref)
  2. package dumpvar;
  3.  
  4. # Needed for PrettyPrinter only:
  5.  
  6. # require 5.001;  # Well, it coredumps anyway undef DB in 5.000 (not now)
  7.  
  8. # translate control chars to ^X - Randal Schwartz
  9. # Modifications to print types by Peter Gordon v1.0
  10.  
  11. # Ilya Zakharevich -- patches after 5.001 (and some before ;-)
  12.  
  13. # Won't dump symbol tables and contents of debugged files by default
  14.  
  15. $winsize = 80 unless defined $winsize;
  16.  
  17.  
  18. # Defaults
  19.  
  20. # $globPrint = 1;
  21. $printUndef = 1 unless defined $printUndef;
  22. $tick = "auto" unless defined $tick;
  23. $unctrl = 'quote' unless defined $unctrl;
  24. $subdump = 1;
  25. $dumpReused = 0 unless defined $dumpReused;
  26.  
  27. sub main::dumpValue {
  28.   local %address;
  29.   local $^W=0;
  30.   (print "undef\n"), return unless defined $_[0];
  31.   (print &stringify($_[0]), "\n"), return unless ref $_[0];
  32.   dumpvar::unwrap($_[0],0);
  33. }
  34.  
  35. # This one is good for variable names:
  36.  
  37. sub unctrl {
  38.     local($_) = @_;
  39.     local($v) ; 
  40.  
  41.     return \$_ if ref \$_ eq "GLOB";
  42.     s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
  43.     $_;
  44. }
  45.  
  46. sub stringify {
  47.     local($_,$noticks) = @_;
  48.     local($v) ; 
  49.     my $tick = $tick;
  50.  
  51.     return 'undef' unless defined $_ or not $printUndef;
  52.     return $_ . "" if ref \$_ eq 'GLOB';
  53.     if ($tick eq 'auto') {
  54.       if (/[\000-\011\013-\037\177]/) {
  55.         $tick = '"';
  56.       }else {
  57.         $tick = "'";
  58.       }
  59.     }
  60.     if ($tick eq "'") {
  61.       s/([\'\\])/\\$1/g;
  62.     } elsif ($unctrl eq 'unctrl') {
  63.       s/([\"\\])/\\$1/g ;
  64.       s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
  65.       s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg 
  66.         if $quoteHighBit;
  67.     } elsif ($unctrl eq 'quote') {
  68.       s/([\"\\\$\@])/\\$1/g if $tick eq '"';
  69.       s/\033/\\e/g;
  70.       s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
  71.     }
  72.     s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
  73.     ($noticks || /^\d+(\.\d*)?\Z/) 
  74.       ? $_ 
  75.       : $tick . $_ . $tick;
  76. }
  77.  
  78. sub ShortArray {
  79.   my $tArrayDepth = $#{$_[0]} ; 
  80.   $tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1 
  81.     unless  $arrayDepth eq '' ; 
  82.   my $shortmore = "";
  83.   $shortmore = " ..." if $tArrayDepth < $#{$_[0]} ;
  84.   if (!grep(ref $_, @{$_[0]})) {
  85.     $short = "0..$#{$_[0]}  '" . 
  86.       join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
  87.     return $short if length $short <= $compactDump;
  88.   }
  89.   undef;
  90. }
  91.  
  92. sub DumpElem {
  93.   my $short = &stringify($_[0], ref $_[0]);
  94.   if ($veryCompact && ref $_[0]
  95.       && (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) {
  96.     my $end = "0..$#{$v}  '" . 
  97.       join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
  98.   } elsif ($veryCompact && ref $_[0]
  99.       && (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) {
  100.     my $end = 1;
  101.       $short = $sp . "0..$#{$v}  '" . 
  102.         join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
  103.   } else {
  104.     print "$short\n";
  105.     unwrap($_[0],$_[1]);
  106.   }
  107. }
  108.  
  109. sub unwrap {
  110.     return if $DB::signal;
  111.     local($v) = shift ; 
  112.     local($s) = shift ; # extra no of spaces
  113.     local(%v,@v,$sp,$value,$key,$type,@sortKeys,$more,$shortmore,$short) ;
  114.     local($tHashDepth,$tArrayDepth) ;
  115.  
  116.     $sp = " " x $s ;
  117.     $s += 3 ; 
  118.  
  119.     # Check for reused addresses
  120.     if (ref $v) { 
  121.       ($address) = $v =~ /(0x[0-9a-f]+)\)$/ ; 
  122.       if (!$dumpReused && defined $address) { 
  123.     ($type) = $v =~ /=(.*?)\([^=]+$/ ;
  124.     $address{$address}++ ;
  125.     if ( $address{$address} > 1 ) { 
  126.       print "${sp}-> REUSED_ADDRESS\n" ; 
  127.       return ; 
  128.     } 
  129.       }
  130.     } elsif (ref \$v eq 'GLOB') {
  131.       $address = "$v" . "";    # To avoid a bug with globs
  132.       $address{$address}++ ;
  133.       if ( $address{$address} > 1 ) { 
  134.     print "${sp}*DUMPED_GLOB*\n" ; 
  135.     return ; 
  136.       } 
  137.     }
  138.  
  139.     if ( UNIVERSAL::isa($v, 'HASH') ) { 
  140.     @sortKeys = sort keys(%$v) ;
  141.     undef $more ; 
  142.     $tHashDepth = $#sortKeys ; 
  143.     $tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1
  144.       unless $hashDepth eq '' ; 
  145.     $more = "....\n" if $tHashDepth < $#sortKeys ; 
  146.     $shortmore = "";
  147.     $shortmore = ", ..." if $tHashDepth < $#sortKeys ; 
  148.     $#sortKeys = $tHashDepth ; 
  149.     if ($compactDump && !grep(ref $_, values %{$v})) {
  150.       #$short = $sp . 
  151.       #  (join ', ', 
  152. # Next row core dumps during require from DB on 5.000, even with map {"_"}
  153.       #   map {&stringify($_) . " => " . &stringify($v->{$_})} 
  154.       #   @sortKeys) . "'$shortmore";
  155.       $short = $sp;
  156.       my @keys;
  157.       for (@sortKeys) {
  158.         push @keys, &stringify($_) . " => " . &stringify($v->{$_});
  159.       }
  160.       $short .= join ', ', @keys;
  161.       $short .= $shortmore;
  162.       (print "$short\n"), return if length $short <= $compactDump;
  163.     }
  164.     for $key (@sortKeys) {
  165.         return if $DB::signal;
  166.         $value = $ {$v}{$key} ;
  167.         print "$sp", &stringify($key), " => ";
  168.         DumpElem $value, $s;
  169.     }
  170.     print "$sp  empty hash\n" unless @sortKeys;
  171.     print "$sp$more" if defined $more ;
  172.     } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) { 
  173.     $tArrayDepth = $#{$v} ; 
  174.     undef $more ; 
  175.     $tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1 
  176.       unless  $arrayDepth eq '' ; 
  177.     $more = "....\n" if $tArrayDepth < $#{$v} ; 
  178.     $shortmore = "";
  179.     $shortmore = " ..." if $tArrayDepth < $#{$v} ;
  180.     if ($compactDump && !grep(ref $_, @{$v})) {
  181.       if ($#$v >= 0) {
  182.         $short = $sp . "0..$#{$v}  " . 
  183.           join(" ", 
  184.            map {stringify $_} @{$v}[0..$tArrayDepth])
  185.         . "$shortmore";
  186.       } else {
  187.         $short = $sp . "empty array";
  188.       }
  189.       (print "$short\n"), return if length $short <= $compactDump;
  190.     }
  191.     #if ($compactDump && $short = ShortArray($v)) {
  192.     #  print "$short\n";
  193.     #  return;
  194.     #}
  195.     for $num ($[ .. $tArrayDepth) {
  196.         return if $DB::signal;
  197.         print "$sp$num  ";
  198.         DumpElem $v->[$num], $s;
  199.     }
  200.     print "$sp  empty array\n" unless @$v;
  201.     print "$sp$more" if defined $more ;  
  202.     } elsif (  UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) { 
  203.         print "$sp-> ";
  204.         DumpElem $$v, $s;
  205.     } elsif ( UNIVERSAL::isa($v, 'CODE') ) { 
  206.         print "$sp-> ";
  207.         dumpsub (0, $v);
  208.     } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
  209.       print "$sp-> ",&stringify($$v,1),"\n";
  210.       if ($globPrint) {
  211.     $s += 3;
  212.     dumpglob($s, "{$$v}", $$v, 1);
  213.       } elsif (defined ($fileno = fileno($v))) {
  214.     print( (' ' x ($s+3)) .  "FileHandle({$$v}) => fileno($fileno)\n" );
  215.       }
  216.     } elsif (ref \$v eq 'GLOB') {
  217.       if ($globPrint) {
  218.     dumpglob($s, "{$v}", $v, 1) if $globPrint;
  219.       } elsif (defined ($fileno = fileno(\$v))) {
  220.     print( (' ' x $s) .  "FileHandle({$v}) => fileno($fileno)\n" );
  221.       }
  222.     }
  223. }
  224.  
  225. sub matchvar {
  226.   $_[0] eq $_[1] or 
  227.     ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and 
  228.       ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
  229. }
  230.  
  231. sub compactDump {
  232.   $compactDump = shift if @_;
  233.   $compactDump = 6*80-1 if $compactDump and $compactDump < 2;
  234.   $compactDump;
  235. }
  236.  
  237. sub veryCompact {
  238.   $veryCompact = shift if @_;
  239.   compactDump(1) if !$compactDump and $veryCompact;
  240.   $veryCompact;
  241. }
  242.  
  243. sub unctrlSet {
  244.   if (@_) {
  245.     my $in = shift;
  246.     if ($in eq 'unctrl' or $in eq 'quote') {
  247.       $unctrl = $in;
  248.     } else {
  249.       print "Unknown value for `unctrl'.\n";
  250.     }
  251.   }
  252.   $unctrl;
  253. }
  254.  
  255. sub quote {
  256.   if (@_ and $_[0] eq '"') {
  257.     $tick = '"';
  258.     $unctrl = 'quote';
  259.   } elsif (@_ and $_[0] eq 'auto') {
  260.     $tick = 'auto';
  261.     $unctrl = 'quote';
  262.   } elsif (@_) {        # Need to set
  263.     $tick = "'";
  264.     $unctrl = 'unctrl';
  265.   }
  266.   $tick;
  267. }
  268.  
  269. sub dumpglob {
  270.     return if $DB::signal;
  271.     my ($off,$key, $val, $all) = @_;
  272.     local(*entry) = $val;
  273.     my $fileno;
  274.     if (($key !~ /^_</ or $dumpDBFiles) and defined $entry) {
  275.       print( (' ' x $off) . "\$", &unctrl($key), " = " );
  276.       DumpElem $entry, 3+$off;
  277.     }
  278.     if (($key !~ /^_</ or $dumpDBFiles) and defined @entry) {
  279.       print( (' ' x $off) . "\@$key = (\n" );
  280.       unwrap(\@entry,3+$off) ;
  281.       print( (' ' x $off) .  ")\n" );
  282.     }
  283.     if ($key ne "main::" && $key ne "DB::" && defined %entry
  284.     && ($dumpPackages or $key !~ /::$/)
  285.     && ($key !~ /^_</ or $dumpDBFiles)
  286.     && !($package eq "dumpvar" and $key eq "stab")) {
  287.       print( (' ' x $off) . "\%$key = (\n" );
  288.       unwrap(\%entry,3+$off) ;
  289.       print( (' ' x $off) .  ")\n" );
  290.     }
  291.     if (defined ($fileno = fileno(*entry))) {
  292.       print( (' ' x $off) .  "FileHandle($key) => fileno($fileno)\n" );
  293.     }
  294.     if ($all) {
  295.       if (defined &entry) {
  296.     dumpsub($off, $key);
  297.       }
  298.     }
  299. }
  300.  
  301. sub dumpsub {
  302.     my ($off,$sub) = @_;
  303.     $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
  304.     my $subref = \&$sub;
  305.     my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub})
  306.       || ($subdump && ($sub = findsubs("$subref")) && $DB::sub{$sub});
  307.     $place = '???' unless defined $place;
  308.     print( (' ' x $off) .  "&$sub in $place\n" );
  309. }
  310.  
  311. sub findsubs {
  312.   return undef unless defined %DB::sub;
  313.   my ($addr, $name, $loc);
  314.   while (($name, $loc) = each %DB::sub) {
  315.     $addr = \&$name;
  316.     $subs{"$addr"} = $name;
  317.   }
  318.   $subdump = 0;
  319.   $subs{ shift() };
  320. }
  321.  
  322. sub main::dumpvar {
  323.     my ($package,@vars) = @_;
  324.     local(%address,$key,$val,$^W);
  325.     $package .= "::" unless $package =~ /::$/;
  326.     *stab = *{"main::"};
  327.     while ($package =~ /(\w+?::)/g){
  328.       *stab = $ {stab}{$1};
  329.     }
  330.     local $TotalStrings = 0;
  331.     local $Strings = 0;
  332.     local $CompleteTotal = 0;
  333.     while (($key,$val) = each(%stab)) {
  334.       return if $DB::signal;
  335.       next if @vars && !grep( matchvar($key, $_), @vars );
  336.       if ($usageOnly) {
  337.     globUsage(\$val, $key) unless $package eq 'dumpvar' and $key eq 'stab';
  338.       } else {
  339.     dumpglob(0,$key, $val);
  340.       }
  341.     }
  342.     if ($usageOnly) {
  343.       print "String space: $TotalStrings bytes in $Strings strings.\n";
  344.       $CompleteTotal += $TotalStrings;
  345.       print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";
  346.     }
  347. }
  348.  
  349. sub scalarUsage {
  350.   my $size = length($_[0]);
  351.   $TotalStrings += $size;
  352.   $Strings++;
  353.   $size;
  354. }
  355.  
  356. sub arrayUsage {        # array ref, name
  357.   my $size = 0;
  358.   map {$size += scalarUsage($_)} @{$_[0]};
  359.   my $len = @{$_[0]};
  360.   print "\@$_[1] = $len item", ($len > 1 ? "s" : ""),
  361.     " (data: $size bytes)\n"
  362.       if defined $_[1];
  363.   $CompleteTotal +=  $size;
  364.   $size;
  365. }
  366.  
  367. sub hashUsage {        # hash ref, name
  368.   my @keys = keys %{$_[0]};
  369.   my @values = values %{$_[0]};
  370.   my $keys = arrayUsage \@keys;
  371.   my $values = arrayUsage \@values;
  372.   my $len = @keys;
  373.   my $total = $keys + $values;
  374.   print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
  375.     " (keys: $keys; values: $values; total: $total bytes)\n"
  376.       if defined $_[1];
  377.   $total;
  378. }
  379.  
  380. sub globUsage {            # glob ref, name
  381.   local *name = *{$_[0]};
  382.   $total = 0;
  383.   $total += scalarUsage $name if defined $name;
  384.   $total += arrayUsage \@name, $_[1] if defined @name;
  385.   $total += hashUsage \%name, $_[1] if defined %name and $_[1] ne "main::" 
  386.     and $_[1] ne "DB::";   #and !($package eq "dumpvar" and $key eq "stab"));
  387.   $total;
  388. }
  389.  
  390. sub packageUsage {
  391.   my ($package,@vars) = @_;
  392.   $package .= "::" unless $package =~ /::$/;
  393.   local *stab = *{"main::"};
  394.   while ($package =~ /(\w+?::)/g){
  395.     *stab = $ {stab}{$1};
  396.   }
  397.   local $TotalStrings = 0;
  398.   local $CompleteTotal = 0;
  399.   my ($key,$val);
  400.   while (($key,$val) = each(%stab)) {
  401.     next if @vars && !grep($key eq $_,@vars);
  402.     globUsage \$val, $key unless $package eq 'dumpvar' and $key eq 'stab';
  403.   }
  404.   print "String space: $TotalStrings.\n";
  405.   $CompleteTotal += $TotalStrings;
  406.   print "\nGrand total = $CompleteTotal bytes\n";
  407. }
  408.  
  409. 1;
  410.  
  411.